MacGames Sampler/PHT MacGames Bundle.iso/MacSource Folder/Samples from the CD/Pascal/Source□/DeHQX-200-Source/DeHQX.p

Text File | 1991-08-23 | 8.8 KB | 358 lines | [TEXT/PJMM]

unit DeHQX;
{ DeHQX v2.0.0 © Peter Lewis, Aug 1991 }

interface

    uses
        MyTypes, MyFileSystem, MyStandardFile, AppGlobals, CRCs, MyUtilities, MyMainLoop, {}
        SmallEvents, MyNotifier, MyMenus, Displays, HQXLists, ReadHQX, DisplayHQX, {}
        MySystem7, Preferences;

    procedure DeHQXFiles;
    procedure DeHQXList;
    procedure DeHQXParameters;
    procedure AddFolder (vrn: integer; dirID: longInt);

implementation

    const
        update_period = 1024;
        display_updates = 1024 div update_period;

    function DoFork (vrn: integer; dirID: longInt; var name: str63; {}
                                    wp: windowPtr; fork: forkType; len: longInt): OSErr;
        type
            updateRange = 0..update_period;
        var
            oe, ooe: OSErr;
            thecrc, actcrc: integer;
            i: longInt;
            j: integer;
            b: byte;
            outfile: integer;
            buffer: packed array[updateRange] of byte;
            bptr: updateRange;
            blen: longInt;
        procedure SimpleHandleUpdateEvents;
            var
                reply: HEReply;
        begin
            HandleCancelErrorEvents(0, nil, oe, reply);
            if reply.todo = T_Update then begin
                BeginUpdate(wp);
                DisplayUpdate(wp);
                EndUpdate(wp);
            end;
        end;
    begin
        crc := 0;
        if fork = data_fork then
            oe := MFSOpenDF(outfile, vrn, dirID, name, POut)
        else
            oe := MFSOpenRF(outfile, vrn, dirID, name, POut);
        DisplayFork(wp, fork, 0, oe);
        SimpleHandleUpdateEvents;
        if oe = noErr then begin
            for i := 1 to len div update_period do begin
                bptr := 0;
                for j := 1 to update_period do begin
                    oe := ReadByte(b);
                    if oe <> noErr then
                        leave;
                    buffer[bptr] := b;
                    bptr := bptr + 1;
                end;
                if oe = noErr then begin
                    blen := bptr;
                    oe := FSWrite(outfile, blen, @buffer);
                end;
                if oe <> noErr then
                    leave;
                SimpleHandleUpdateEvents;
                if oe <> noErr then
                    leave;
                if i mod display_updates = 0 then
                    DisplayFork(wp, fork, i * update_period, oe);
            end;
            if oe = noErr then begin
                bptr := 0;
                for j := 1 to len mod update_period do begin
                    oe := ReadByte(b);
                    if oe <> noErr then
                        leave;
                    buffer[bptr] := b;
                    bptr := bptr + 1;
                end;
                if oe = noErr then begin
                    blen := bptr;
                    oe := FSWrite(outfile, blen, @buffer);
                end;
            end;
            CalcCRC(crc, 0);
            CalcCRC(crc, 0);
            actcrc := crc;
            if oe = noErr then
                oe := ReadInteger(thecrc);
            if (actcrc <> thecrc) and (oe = noErr) then
                oe := HqxFormatErr;
            DisplayFork(wp, fork, len, oe);
            ooe := FSClose(outfile);
        end;
        DoFork := oe;
    end;

    procedure DeHQXList;
        const
            fin_err = 1;
        var
            reply: MySFReply;
            oe, ooe: integer;
            hi: hqxInfo;
            wp: windowPtr;
            any_saved, any_errors, first_save: boolean;
            alertID, alertButton: integer;
            dummy_name: str255;
            prompting: promptStates;
            savefolder: boolean;
            ovrn: integer;
            odirID: longInt;
            did_something: boolean;
            fdel, fstop: boolean;
        procedure SetFirstSave (vrn: integer; dirID: longInt);
        begin
            if first_save then begin
                SetSFFile(vrn, dirID);
                first_save := false;
            end;
        end;
        procedure Interact;
            var
                oe: OSErr;
        begin
            oe := MyInteractWithUser(nil);
        end;
    begin
        if AnyInputFiles then begin
            OpenDisplay(wp);
            first_save := true;
            prompting := prefs.prompt_state;
            oe := noErr;
            while AnyInputFiles and (oe <> cancelErr) do begin
                did_something := true;
                StartList;
                savefolder := false;
                any_saved := false;
                any_errors := false;
                oe := OpenHQX;
                while oe = noErr do begin
                    oe := ReadHeader(hi, wp);
                    if oe = noErr then begin
                        with reply do begin
                            RfName := hi.name;
                            Rgood := true;
                            if savefolder then begin
                                RvRefNum := ovrn;
                                RdirID := odirID;
                            end
                            else
                                CreateFolder(RvRefNum, RdirID);
                            case prompting of
                                PS_Always:
                                    begin
                                    Interact;
                                    SetFirstSave(RvRefNum, RdirID);
                                    PutFolder(GetGlobalString(sfput_string), RfName, put_folder_id, reply);
                                    if Rgood and Rfolder then begin
                                        if RfName = '' then begin
                                            RfName := hi.name;
                                            MFSUniqueName(RvRefNum, RdirID, RfName);  { cant really put up another dialog box! }
                                        end;
                                        savefolder := true;
                                        prompting := PS_Exists;
                                        ovrn := RvRefNum;
                                        odirID := RdirID;
                                    end;
                                end;
                                PS_Exists:
                                    if MFSExists(RvRefNum, RdirID, RfName) then begin
                                        Interact;
                                        SetSFFile(RvRefNum, RdirID);
                                        PutFolder(GetGlobalString(sfput_string), RfName, put_folder_id, reply);
                                        if Rgood then begin
                                            if Rfolder then begin
                                                savefolder := true;
                                                ovrn := RvRefNum;
                                                odirID := RdirID;
                                            end
                                            else begin
                                                savefolder := false;
                                                prompting := prefs.prompt_state;
                                            end;
                                        end;
                                    end;
                                PS_Skip:
                                    Rgood := not MFSExists(RvRefNum, RdirID, RfName);
                                PS_Overwrite:
                                    ;
                                PS_Unique:
                                    MFSUniqueName(RvRefNum, RdirID, RfName);
                            end; {case}
                            if not Rgood then
                                cycle;
                            with hi do begin
                                name := RfName;
                                wdrn := RvRefNum;
                                dirID := RdirID;
                                DisplayOpen(wp, hi);
                                if oe = noErr then
                                    oe := MFSCreate(RvRefNum, RdirID, RfName, c, t);
                                if oe = noErr then
                                    oe := DoFork(RvRefNum, RdirID, RfName, wp, data_fork, dlen);
                                if oe = noErr then
                                    oe := DoFork(RvRefNum, RdirID, RfName, wp, rsrc_fork, rlen);
                                if oe = noErr then begin
                                    oe := ReadColon;
                                end;
                                DisplayFinish(wp, oe);
                            end; {with}
                            if oe = noErr then begin
                                any_saved := true;
                            end
                            else begin
                                ParamText(RfName, '', '', '');
                                any_errors := true;
                                case oe of
                                    cancelErr:
                                        begin
                                        fdel := true;
                                        fstop := true;
                                    end;
                                    HqxFormatErr:
                                        begin
                                        Interact;
                                        alertButton := Alert(hqx_error_alert_id, nil);
                                        fstop := not odd(alertButton);
                                        fdel := alertButton < 3;
                                    end;
                                    otherwise
                                        begin
                                        Interact;
                                        alertButton := Alert(disk_error_alert_id, nil);
                                        fstop := alertButton = 1;
                                        fdel := true;
                                    end;
                                end;
                                if fstop then
                                    oe := cancelErr
                                else begin
                                    oe := noErr;
                                    quitNow := false;
                                    HiliteMenu(0);
                                end;
                                if fdel then
                                    ooe := MFSDelete(RvRefNum, RdirID, RfName);
                            end;
                            DisplayClose(wp);
                        end; {with}
                    end; {if}
                end;
                FinishHQX;
                FinishList(prefs.delete_state and any_saved and not any_errors);
            end;
            if did_something then begin
                if prefs.auto_quit_state and any_saved and not any_errors then
                    quitNow := true;
                if (oe <> cancelErr) or not in_foreground then begin  { No sense beeping and notifying if the user canceled! }
                    if prefs.beep_state then
                        SysBeep(3);
                    if prefs.notify_state and not in_foreground then
                        Notify(true, false, 128, 1, 0, 0);
                end;
            end;
            CloseDisplay(wp);
            size_in_lists := 0;
            size_processed := 0;
        end;
    end;

    function HQXHook (var pb: HParamBlockRec): boolean;
    begin
        case prefs.display_state of
            DS_All:
                HQXHook := false;
            DS_TEXT:
                HQXHook := pb.ioFlFndrInfo.fdType <> 'TEXT';
            DS_HQX:
                HQXHook := (pb.ioFlFndrInfo.fdType <> 'TEXT') or not EqualString(Copy(pb.ioNamePtr^, length(pb.ioNamePtr^) - 2, 3), 'hqx', false, false);
        end;
    end;

    procedure AddFolder (vrn: integer; dirID: longInt);
        var
            pb: HParamBlockRec;
            name: str255;
            i: integer;
            oe: OSErr;
    begin
        i := 1;
        with pb do
            repeat
                name := '';
                ioNamePtr := @name;
                ioVRefNum := vrn;
                ioDirID := dirID;
                ioFVersNum := 0;
                ioFDirIndex := i;
                i := i + 1;
                oe := PBHGetFInfo(@pb, false);
                if oe = noErr then
                    if not HQXHook(pb) then begin
                        AddFile(vrn, dirID, name, prefs.create_dir_state <> CDS_Never, pb.ioFlLgLen);
                    end;
            until oe <> noErr;
    end;

    procedure DeHQXFiles;
        var
            typeList: SFTypeList;
            reply: MySFReply;
            ovrn: integer;
            dirID: longInt;
            oe: OSErr;
    begin
        GetFolder(@HqxHook, -1, typeList, get_folder_id, reply);
        HiliteMenu(0);
        with reply do
            if Rgood then begin
                if not Rfolder then begin
                    AddFile(RvRefNum, RdirID, RfName, prefs.create_dir_state = CDS_Always, -1);
                end
                else begin
                    AddFolder(RvRefNum, RdirID);
                end;
            end;
    end;

    procedure DeHQXParameters;
        var
            paramCount, paramMessage, i: integer;
            tf: appFile;
            pb: paramBlockRec;
            ovrn: integer;
            odirID, dirID: longInt;
            oe: OSErr;
            sh: stringHandle;
    begin
        CountAppFiles(paramMessage, paramCount);
        GetAppFiles(1, tf);
        for i := 1 to paramCount do begin
            GetAppFiles(i, tf);
            if tf.fType <> myAppType then begin
                oe := GetDirID(tf.vRefNum, ovrn, odirID);
                AddFile(ovrn, odirID, tf.fName, prefs.create_dir_state <> CDS_Never, -1);
                ClrAppFiles(i);
            end;
        end;
    end;

end.